00100	C***** F4PAG.F4 *********
00200	C**** SHFTQ, SORT2, NORH, MINMAX, PFIBX, PFIB, RLOOP, BLTEM
00300		SUBROUTINE SHFTQ(R)
00400		COMMON /JN/JN,JX /XRN/MM(1) /Q/Q(1)
00500		DO 1 K=1,JX
00600		L=MM(K)
00700	1	Q(L)=Q(L)+R
00800	C SHIFTS  ALL POSITION PARAMS.
00900		END
01000	
01100		SUBROUTINE SORT2(RPOS,M)
01200		DIMENSION RPOS(2,200)
01300		L=2
01400	3	J=-1
01500		RX=RPOS(1,L-1)
01600		DO 2 K=L,M
01700		IF(RPOS(1,K).GE.RX)GO TO 2
01800		RX=RPOS(1,K)
01900		J=K
02000	2	CONTINUE
02100		IF(J.LT.0)GO TO 4
02200		K=L-1
02300	C  EXCHANGE THE POSITIONS IN THE LIST
02400		RX=RPOS(1,K)
02500		RPOS(1,K)=RPOS(1,J)
02600		RPOS(1,J)=RX
02700		RX=RPOS(2,K)
02800		RPOS(2,K)=RPOS(2,J)
02900		RPOS(2,J)=RX
03000	4	L=L+1
03100		IF(L.LE.M)GO TO 3
03200		END
03300	
03400		FUNCTION NORH(KK,K)
03500		COMMON /XRN/R(500),NN(1)
03600	C FIND VALUE IN NN ARRAY IN DO LOOP.
03700		KK=NN(K)
03800		NORH=0
03900		IF(KK.LE.0)GO TO 1
04000	C NORH=-1 IF KK≤0, >18, NOT 1,2,4,17.
04100		IF(KK.LE.2.OR.KK.EQ.4)RETURN
04200		IF(KK.EQ.17.OR.KK.EQ.18)RETURN
04300	1	NORH=-1
04400		END
04500	
04600		SUBROUTINE FNDEND(R)
04700		COMMON /XRN/RN(500),NN(1) /ENDL/ENDLN
04800		K=1
04900	1	N=NN(K)
05000		IF(N.LE.0)GO TO 2
05100		IF(N.LE.3.OR.N.EQ.17.OR.N.EQ.18)GO TO 3
05200	2	K=K+1
05300		GO TO 1
05400	C ASSUMES IT WILL ALWAYS END PROPERLY
05500	3	R=ENDLN+2.0-RN(K)
05600		END
05700	
05800		SUBROUTINE MINMAX(JRN)
05900		COMMON /MNX/MIN,MAX,JT
06000		DIMENSION JRN(1)
06100	C GET FIRST VALUE OF CURRENT JRN ARRAY
06200		MIN=JRN(1)
06300		MAX=MIN
06400		DO 107 K=1,JT
06500		NN=JRN(K)
06600		IF(NN.LT.MIN)MIN=NN
06700	107	IF(NN.GT.MAX)MAX=NN
06800		END
06900	
07000		FUNCTION PFIBX(A)
07100		DATA FIB/0.618/, RFIB/-.382/
07200		PFIBX=14.
07300		IF(A.EQ.1.)RETURN
07400		Z=FIB
07500		X=ALOG(A)/0.6931472
07600		RH=ABS(X)
07700		IF(X.LE.0)Z=RFIB
07800		L=RH
07900		IF(L.EQ.0)GO TO 4
08000		DO 3 K=1,L
08100	3	PFIBX=PFIBX+PFIBX*Z
08200	4	RH=RH-L
08300		IF(RH.EQ.0)RETURN
08400		PFIBX=PFIBX+PFIBX*Z*RH
08500	C SEND BACK THE RESULT
08600		END
08700	
08800		FUNCTION PFIB(P)
08900	C   PSEUDO-FIBONACCI RHYTHM SPACER
09000		PFIB=(P+(.125-P)*(.8+.02*P))*50
09100		END
09200	
09300		SUBROUTINE RLOOP(A,B,K)
09400		DIMENSION A(1),B(1)
09500		DO 1 J=1,K
09600	1	A(J)=B(J)
09700		END
09800	
09900	C  BLTEM BLTS (WHEN IN FAIL) ARRAYS KPN AND Q INTO KWDS AND RN
10000		SUBROUTINE BLTEM
10100		COMMON /XRN/RN(1) /PTR/KWDS(1) /PX/KPN(1) /Q/Q(1)
10200		COMMON /POSI/STFF(8),JJ2,JPQ /RCLF/KK,CLEF,KW,ITEM
10300	CC	DO 1511 K=1,ITEM+1
10400	CC1511	KWDS(K)=KPN(K)
10500	CC	DO 1611 K=1,JPQ
10600	CC1611	RN(K)=Q(K)
10700		CALL RLOOP(KWDS,KPN,ITEM+1)
10800		CALL RLOOP(RN,Q,JPQ)
10900		END